home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / BARNET / COMPILER / SATHER / !Sather / Library / Graphs / sa / wtd_dgr_al < prev    next >
Text File  |  1996-07-13  |  9KB  |  244 lines
  1. ---------------------------> Sather 1.1 source file <--------------------------
  2. -- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>
  3. -- Copyright (C) 1995, International Computer Science Institute
  4. -- $Id: wtd_digraph_alg.sa,v 1.6 1996/07/13 05:42:12 gomes Exp $
  5. --
  6. -- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
  7. -- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
  8. -- LICENSE contained in the file: Sather/Doc/License of the
  9. -- Sather distribution. The license is also available from ICSI,
  10. -- 1947 Center St., Suite 600, Berkeley CA 94704, USA.
  11. -------------------------------------------------------------------
  12. class WTD_DIGRAPH_ALG{NTP<$STR,WT<$NUMBER{WT},GTP<$LBLD_DIGRAPH{NTP,WT,WT}} is
  13.    --   NTP,            -- Node type
  14.    --   WT<$NUMBER{WT},        -- Weight type
  15.    --   GTP<$LBLD_DIGRAPH{NTP,WT,WT} -- Labelled Graph type
  16.    --   Largely translated from the LEDA library
  17.    -- 
  18.    -- Usage:
  19.    --   It is simplest to use these algorithms by including
  20.    --   them using WTD_DIGRAPH_INCL. For instance, see WTD_DIGRAPH{STR,FLT}, 
  21.    --   You can also directly call thes routines  See TEST_WTD_DIGRAPH
  22.    --   If you have to use this class directly, keep the parameters straight!
  23.    
  24.    include  COMPARE{NTP};
  25.    
  26.    shared debug: BOOL := false;
  27.  
  28.    maxval: WT is return WT::maxval end;
  29.    zero: WT is  return WT::zero end;
  30.  
  31.    bellman_ford(g:GTP,s:NTP,out d:MAP{NTP,WT},out p:MAP{NTP,NTP}): BOOL
  32.    -- Computes the source shortest paths from "s" using a queue and
  33.    -- breadth first search.  On return, "d" holds a mapping from
  34.    -- nodes to their distances for "src" and "pred" holds a mapping
  35.    -- from each node to its parent node in the shortest paths
  36.    -- tree. Returns true if no negative cycle was found
  37.    -- 
  38.    -- 
  39.    -- Implementation: Note that bellman_ford works even in cyclic
  40.    -- graphs, provided there is no cycle with negative weight (in
  41.    -- which case the min weight to any of the nodes in the cycle
  42.    -- can be arbitrarily decreased) If such a negative weight cycle
  43.    -- is found, the routine quits and returns false - it can
  44.    -- therefore also be used as a reliable detector of negative
  45.    -- cycles.
  46.    -- 
  47.    is
  48.       if ~g.are_all_edges_labelled then
  49.      raise #GRAPH_EXC(g,"bellman_ford","","").missing_edge_labels;
  50.       end;
  51.       src ::= s; 
  52.       dist:MAP{NTP,WT} := #;
  53.       pred:MAP{NTP,NTP} := #;
  54.       q: QUEUE{NTP} := #;
  55.       in_q: MAP{NTP,BOOL} := #;    -- Is a node in the queue?
  56.       count: MAP{NTP,INT} := #;    -- Number of times visited
  57.       loop n ::= g.node!; dist[n] := maxval; pred[n] := void;  end; 
  58.       dist[src] := zero;
  59.       q.enq(src);
  60.       -- deb2("Original q:"+q);
  61.       in_q[src] := true;
  62.       loop while!(~q.is_empty); -- deb2("Queue:"+q.str+"Distance:"+dist.str);
  63.      u ::= q.remove;
  64.      in_q[u] := false;
  65.      count[u] := count[u]+1;
  66.      if count[u] > g.n_nodes then return false; end; -- A Negative cycle
  67.      cost_u: WT := dist[u];
  68.      cost_u_v:WT;cost_v: WT;
  69.      loop v ::= g.outgoing!(u, out cost_v,out cost_u_v);
  70.         cost_v := cost_u+cost_u_v;
  71.         if cost_v < dist[v] then 
  72.            -- If we are now on the shortest path to "v", then revise
  73.            -- the prev of "v" and its cost
  74.            --deb2("Updating cost of:"+v.str+" to:"+cost_v);
  75.            dist[v] := cost_v;    pred[v] := u;
  76.            if ~in_q[v] then  q.enq(v); in_q[v] := true;    end;
  77.         end; -- If new short path to v
  78.      end; -- Go through neighbors of u
  79.       end; -- While the queue is not empty
  80.       -- Assign out arguments
  81.       d := dist; 
  82.       p := pred;
  83.       return true;
  84.    end;
  85.  
  86.    dijkstra(g:GTP,s:NTP,out dist:MAP{NTP,WT},out pred:MAP{NTP,NTP}) 
  87.    -- Please see the comment at WTD_DIGRAPH_ALG{_,_,_,_}::dijkstra
  88.    -- Computes single source shortest paths from "src" for a
  89.    -- non-negative graph i.e. one without negative cycles.  Returns
  90.    -- the distance from "src" to all other nodes in "dist" and the
  91.    -- predecessor of each node of "g" in the shortest paths tree in
  92.    -- "pred"
  93.    -- 
  94.    -- Usage: 
  95.    --   See bellman_ford
  96.       pre g.are_all_edges_labelled
  97.    is
  98.       pq: A_PQ{PQMINWT{NTP,WT}} := #;
  99.       -- Note that pq_elts has a mapping into the actual "weight"
  100.       -- objects stored in "pq", thus allowing us to externally
  101.       -- change the weight associated with an item using the element
  102.       pq_elts: MAP{NTP,PQMINWT{NTP,WT}} := #;
  103.       dist := #;
  104.       pred := #;
  105.       loop n ::= g.node!; dist[n] := maxval; pred[n] := void end;
  106.       dist[s] := zero;
  107.       e ::= #PQMINWT{NTP,WT}(s,zero);    pq_elts[s]:= e;     pq.insert(e);
  108.       loop while!(~pq.is_empty);
  109.      -- deb2("PQ:"+pq.str+"Distance:\n:"+dist);
  110.      uel ::= pq.remove;
  111.      u:NTP := uel.element; 
  112.      du: WT := dist[u];
  113.      -- deb2("du:"+du.str+"\n");      -- deb2("u:"+u.str+"\n");
  114.      cost_u_v:WT;cost_v: WT;
  115.      loop v ::= g.outgoing!(u,out cost_v, out cost_u_v);
  116.         -- Returns the set of outgoing edges
  117.         cost_v := du+cost_u_v;
  118.         if cost_v < dist[v] then
  119.            -- If this is the shortest path to "v" then update cost to v
  120.            -- deb2("Revising cost of:"+v.str+" to"+cost_v.str+"\n");
  121.            if dist[v] = maxval then 
  122.           -- Since v is not initialized, add it to pq
  123.           et::=#PQMINWT{NTP,WT}(v,zero);
  124.           pq_elts[v]:= et; 
  125.           pq.insert(et);
  126.            else 
  127.           -- This changes the weight in the actual priority queue
  128.           -- as well, since it uses the same elements
  129.           pq_elts[v].weight := cost_v; 
  130.            end;
  131.            dist[v] := cost_v;
  132.            pred[v] := u;
  133.         end;
  134.      end;
  135.       end;
  136.    end;
  137.  
  138.    max_weight_path_node!(once g: GTP,once  src,once sink: NTP): NTP 
  139.    -- Computes the maximum node-weight path from "src" to "sink" in
  140.    -- the graph "g", returning a list of nodes in that maximum weight
  141.    -- path that starts with "src" and ends with "sink" Fully
  142.    -- considered only for DAGs: May have problems with other types of
  143.    -- graphs
  144.      pre g.are_all_nodes_labelled
  145.    is
  146.       -- This algorithm deals with node weights, rather than edge
  147.       -- weights. Return nodes on the maximum weight (critical) path
  148.       -- from "src" to "sink"
  149.       -- Current maximum weight to a node
  150.       max_weight: FMAP{NTP,WT} := #;
  151.       -- Incoming node with the maximum weight to a node
  152.       max_in_node: FMAP{NTP,NTP} := #;
  153.       -- Number of incoming edges that have been seen already
  154.       n_edges_considered: FMAP{NTP,INT} := #;
  155.       loop 
  156.      n ::= g.node!;
  157.      max_weight := max_weight.insert(n,-WT::maxval);
  158.      n_edges_considered := n_edges_considered.insert(n,0);
  159.       end;
  160.       consider ::= #FLIST{NTP};
  161.       n_considered ::= 1;
  162.       consider := consider.push(src);
  163.       src_weight ::= g.node_label(src);
  164.       -- Start with the source node
  165.       max_weight := max_weight.insert(src,src_weight);
  166.       new_consider: FLIST{NTP} := #;
  167.       loop until!(consider.size = 0);
  168.      -- "consider" holds the list of nodes whose children's
  169.      -- weights must be recomputed
  170.      assert deb("L1:w:"+max_weight+"consider:"+consider.str);
  171.      loop
  172.         -- Go through all the nodes to consider
  173.         parent ::= consider.elt!;
  174.         parent_wt ::= max_weight.get(parent);
  175.         assert deb("Parent:"+parent.str+" Max wt:"+str(parent_wt));
  176.         loop child ::= g.outgoing!(parent);
  177.            child_wt ::= g.node_label(child); -- Get the child weight
  178.            assert deb("Child:"+child.str+" node weight:"+str(child_wt));    
  179.            n_in ::= n_edges_considered.get(child);
  180.            n_edges_considered := n_edges_considered.insert(child,n_in+1);
  181.            if n_in+1 = g.n_incoming(child) then
  182.           -- If all incoming edges to the child have been
  183.           -- considered then the child's weight is recomputes
  184.           new_consider := new_consider.push(child);
  185.            end;
  186.            max_wt::=max_weight.get(child); -- Get the maxwt to the child
  187.            new_max_wt ::= parent_wt+child_wt; -- Compute the new max
  188.            assert deb("Old max wt:"+str(max_wt)+" new"+str(new_max_wt));
  189.            if new_max_wt > max_wt then -- Update the max wt
  190.           assert deb("Changed wt:"+child.str+" new"+str(new_max_wt));
  191.           max_weight := max_weight.insert(child,new_max_wt);
  192.           max_in_node := max_in_node.insert(child,parent);
  193.            end;
  194.         end; -- Loop over all elements to consider
  195.      end; -- Loop until "consider" is empty
  196.      consider.clear;
  197.      tmp ::= consider;
  198.      consider := new_consider;
  199.      new_consider := tmp;
  200.       end;
  201.       -- Now trace the max path backwards from the dest
  202.       n ::= sink;
  203.       path: LIST{NTP} := #;
  204.       loop until!(elt_eq(n,src)); 
  205.      assert deb("next mwp node:"+node_str(n));
  206.      yield n;
  207.      if ~max_in_node.test(n) then
  208.         #ERR+"*****Maximum weight source not found!!!****\n";
  209.         #ERR+"Maximum weight table:\n"+max_weight.str+"\n";
  210.         #ERR+"Maximum in node:\n"+max_in_node.str+"\n";
  211.         #ERR+"N edges considered:\n"+n_edges_considered.str+"\n";
  212.         raise "Maximum path sink was not reached from source!\n";
  213.      end;
  214.      n := max_in_node.get(n); 
  215.       end;
  216.       yield src;
  217.    end;
  218.  
  219.    private deb(s: STR): BOOL is 
  220.       if debug  then #ERR+s+"\n"; end;
  221.       return true;
  222.    end;
  223.    
  224.    private deb2(s: STR) is     #ERR+s+"\n"; end;
  225.  
  226.    private node_str(n: NTP): STR is
  227.       typecase n
  228.       when $STR then return n.str 
  229.       else return SYS::id(n).str;   end;
  230.    end;
  231.  
  232.    private str(e: $OB): STR is
  233.       typecase e
  234.       when $STR then return e.str 
  235.       else 
  236.      if ~void(e) then return SYS::id(e).str;
  237.      else return "Void" end;
  238.       end;
  239.    end;
  240.  
  241. end; -- class WTD_DIGRAPH_ALG
  242. -------------------------------------------------------------------
  243.  
  244.